home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 20 / Cream of the Crop 20 (Terry Blount) (1996).iso / program / fact127.zip / FACT.PAS < prev    next >
Pascal/Delphi Source File  |  1996-05-23  |  32KB  |  1,083 lines
  1. PROGRAM Freeware_Archive_Conversion_Tool;
  2. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  3. | Program:    FACT (Freeware Archive Conversion Tool)
  4. | Version:    1.27 - May 23, 1996
  5. | Author:     David Daniel Anderson
  6. | Copyright applies, but feel free to use "fair-use" size portions of code.
  7. -----------------------------------------------------------------------------*)
  8. {$M 20480,0,655360}
  9. {$N-,E- no math support needed}
  10. {$X- function calls may not be discarded}
  11. {$I- disable I/O checking (trap errors by checking IOResult)}
  12.  
  13. USES DOS, HeapMan;
  14. TYPE
  15.   STR128 = STRING[128];
  16.   FList = ^FNode;
  17.   FNode = RECORD
  18.             ArcFName: STRING[12];  { File names of archives to process. }
  19.             DelWhenDone: BOOLEAN;  { Does FACT delete archive when done? }
  20.             Next: FList;
  21.           END;
  22.   ArcCommands = RECORD
  23.                   ReCompress: STR128;  { Command line for each ReCompressor. }
  24.                   DeCompress: STR128;  { Command line for each DeCompressor. }
  25.                   DirsCompressed: BOOLEAN;  { Does compressor compress dirs? }
  26.                 END;
  27. VAR
  28.   SavedExitProc: POINTER;  { CustomExit proc inserted into normal exit. }
  29.   ComSpec: PATHSTR;        { Used to execute commands. }
  30.   WATCH,                   { If TRUE, ReadLn executed after info messages. }
  31.   DelOriginal,             { If TRUE, the original archive is deleted. }
  32.   QUIET,                   { If TRUE, most compressor output is suppressed. }
  33.   ONE: BOOLEAN;            { If TRUE, convert only the primary archive. }
  34.   RecursionLevel: BYTE;    { How deep the recursion is, affects ZIP archives. }
  35.   NewExt: EXTSTR;          { New extension -- for recompressed archives. }
  36.   ArcString: STRING;       { String of extensions of validated compressors. }
  37.   ArcArray: Array[1..244] of ArcCommands;  { Commands for archive types. }
  38.   FileList: FList;         { Singly linked list of archives to process. }
  39.  
  40. FUNCTION getFileName (fn: STR128): NAMESTR; FORWARD;
  41. PROCEDURE NewLine; FORWARD;
  42. PROCEDURE WriteStr (CONST s: STRING); FORWARD;
  43. FUNCTION WordToHex (i: WORD): EXTSTR; FORWARD;
  44.  
  45. PROCEDURE CustomExit; FAR; {---- Always exit through here ----}
  46. CONST
  47.   NL = #13#10;
  48. VAR
  49.   message: STRING [79];
  50. BEGIN
  51.   ExitProc := SavedExitProc;
  52.   IF (ExitCode > 0) THEN BEGIN
  53.     NewLine;
  54.     WriteStr ('FACT v1.27 - DOS utility: Freeware Archive Conversion Tool.');
  55.     WriteStr ('May 23, 1996. Copyright (c) 1996 by David Daniel Anderson - Reign Ware.'+NL);
  56.     WriteStr ('   Usage :  FACT archives .NewExt [-d] [-q] [-w] [-1]'+NL);
  57.     WriteStr ('   Where :  "archives" is specification of the archives to convert.');
  58.     WriteStr ('         :  ".NewExt" is the extension(s) you wish to convert them to.');
  59.     WriteStr ('         :  "-d"=del - forces the original archive to be deleted.  [Optional]');
  60.     WriteStr ('         :  "-q"=quiet - hides most of the compressors'' messages.  [Optional]');
  61.     WriteStr ('         :  "-w"=watch - causes FACT to pause after every action.  [Optional]');
  62.     WriteStr ('         :  "-1"=1 level - only recompress the _primary_ archive.  [Optional]'+NL);
  63.     WriteStr ('Examples :  FACT c:\dls\*.zip .lzh');
  64.     WriteStr ('         :  FACT somefile.arc .arj .zip .uc2 -d');
  65.     WriteStr ('         :  FACT anyfiles.* .rar -d -q'+NL);
  66.     WriteStr ('   Hints :  DOS wildcards may be used when specifying the archives.');
  67.     WriteStr ('         :  Multiple ".NewExt" new extensions may be specified at one time.'+NL);
  68.   END;
  69.   IF ErrorAddr <> NIL THEN
  70.   BEGIN
  71.     WriteStr ('An unanticipated error occurred, please contact DDA with the following data:');
  72.     WriteLn ('Address = ', WordToHex (Seg (ErrorAddr^)), ':', WordToHex (Ofs (ErrorAddr^)));
  73.     WriteLn ('Code    = ', ExitCode);
  74.     ErrorAddr := NIL;
  75.   END
  76.   ELSE
  77.     IF (ExitCode IN [1..254]) THEN BEGIN
  78.       CASE ExitCode OF
  79.         1 : message := 'No '+getFileName (ParamStr (0))+'.INI file found.  It must be in same dir as '+ParamStr(0)+'.';
  80.         2 : message := 'No defined archives found matching "'+ParamStr(1)+'"!';
  81.         3 : message := 'None of the ".NewExt" compressors were validated.';
  82.         4 : message := 'User aborted while in "watch" mode.  Working files may remain!';
  83.         6 : message := '"COMSPEC" not set!  Type "COMSPEC=c:\dos\command.com" (or similar) to set it.';
  84.         7 : message := 'File handling error.  There are likely files and directories to clean up now.';
  85.         ELSE  message := 'Unknown error.';
  86.       END;
  87.       WriteLn ('Error encountered (#', ExitCode, '):'); WriteStr (message);
  88.     END;
  89. END;
  90.  
  91. PROCEDURE CheckIO; { Check IOResult, exit on error. }
  92. BEGIN
  93.   IF IOResult <> 0 THEN Halt (7);
  94. END;
  95.  
  96. PROCEDURE NewLine;
  97. BEGIN
  98.   WriteLn;
  99. END;
  100.  
  101. PROCEDURE WriteStr (CONST s: STRING);
  102. BEGIN
  103.   WriteLn (s);
  104. END;
  105.  
  106. FUNCTION WordToHex (i: WORD): EXTSTR; {Convert a WORD variable to STRING[4]}
  107. CONST
  108.   HexLetters : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
  109. BEGIN
  110.   WordToHex := Concat (HexLetters [Hi (i) SHR 4], HexLetters [Hi (i) AND 15],
  111.                        HexLetters [Lo (i) SHR 4], HexLetters [Lo (i) AND 15]);
  112. END;
  113.  
  114. PROCEDURE ClrScr; ASSEMBLER;
  115. (* Routine from SWAG *)
  116. ASM
  117.   MOV AH, 0Fh
  118.   Int 10h
  119.   MOV AH, 0
  120.   Int 10h
  121. END;
  122.  
  123. PROCEDURE Delay (ms : WORD); ASSEMBLER;
  124. ASM {machine independent Delay Function}
  125.   mov AX, 1000;
  126.   mul ms;
  127.   mov CX, DX;
  128.   mov DX, AX;
  129.   mov AH, $86;
  130.   Int $15;
  131. END;
  132.  
  133. PROCEDURE Pause; { Pauses for WATCH mode. }
  134.   FUNCTION ReadKey: CHAR;
  135.   VAR
  136.     r: REGISTERS;
  137.   BEGIN
  138.     r. AX := $0700;
  139.     Intr ($21, r);
  140.     ReadKey := Chr (r. AL);
  141.   END;
  142.  
  143. VAR
  144.   k: CHAR;
  145. BEGIN
  146.   NewLine;
  147.   WriteStr ('Watch mode: press "N" to stop watching, or "A" to abort FACT.');
  148.   Write ('Otherwise, press any other normal key to continue ... ');
  149.   k := ReadKey;
  150.   Write (k);
  151.   IF k IN ['n', 'N'] THEN WATCH := FALSE;
  152.   IF k IN ['a', 'A'] THEN Halt (4);
  153.   NewLine;
  154.   NewLine;
  155. END;
  156.  
  157. FUNCTION CommandProg (fn : STR128): STR128; {Separate prog name from switches.}
  158. BEGIN
  159.   IF (Pos (#32, fn) > 0)
  160.     THEN CommandProg := Copy (fn, 1, (Pos (#32, fn) - 1))
  161.     ELSE CommandProg := fn;
  162. END;
  163.  
  164. FUNCTION CommandTail (fn : STR128): STR128; {Separate prog switches from name.}
  165. BEGIN
  166.   IF (Pos (#32, fn) > 0)
  167.     THEN CommandTail := Copy (fn, Pos (#32, fn), Length (fn))
  168.     ELSE CommandTail := '';
  169. END;
  170.  
  171. FUNCTION RPad (bstr: STRING; len: BYTE): STRING;
  172. BEGIN
  173.   WHILE (Length (bstr) < len) DO
  174.     bstr := bstr + #32;
  175.   RPad := bstr;
  176. END;
  177.  
  178. FUNCTION RTrim (InStr: STRING): STRING;
  179. BEGIN
  180.   WHILE (Length (InStr) > 0) AND (InStr [Length (InStr)] IN [#0, #9, #32]) DO
  181.     Dec (InStr [0]);
  182.   RTrim := InStr;
  183. END;
  184.  
  185. FUNCTION LTrim (InStr: STRING): STRING;
  186. BEGIN
  187.   WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
  188.     Delete (InStr, 1, 1);
  189.   LTrim := InStr;
  190. END;
  191.  
  192. FUNCTION Trim (InStr: STRING): STRING;
  193. BEGIN
  194.   Trim := RTrim (LTrim (InStr));
  195. END;
  196.  
  197. FUNCTION Upper (lstr: STRING): STRING;
  198.   PROCEDURE UpFast (VAR Str: STRING);  {** from SWAG **}
  199.   INLINE($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
  200.          $AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
  201. BEGIN
  202.   UpFast (lstr);
  203.   Upper := lstr;
  204. END;
  205.  
  206. FUNCTION IsSwitch (sSwitch: STRING): BOOLEAN;
  207. VAR
  208.   Return : BOOLEAN;
  209.   Param : STRING;
  210.   pc : BYTE;
  211. BEGIN
  212.   Return := FALSE;
  213.   IF (ParamCount > 2) THEN
  214.   BEGIN
  215.     sSwitch := Upper (sSwitch);
  216.     FOR pc := 3 to ParamCount DO
  217.     IF (Return = FALSE) THEN
  218.     BEGIN
  219.       Param := Upper (ParamStr (pc));
  220.       IF (Pos ('/'+sSwitch, Param) > 0) OR (Pos ('-'+sSwitch, Param) > 0)
  221.         THEN Return := TRUE;
  222.     END;
  223.   END;
  224.   IsSwitch := Return;
  225. END;
  226.  
  227. FUNCTION getFileExt (fn: STR128): EXTSTR;
  228. VAR
  229.   p: BYTE;
  230. BEGIN
  231.   p := (Pos ('.', fn));
  232.   IF (p > 0)
  233.     THEN getFileExt := Copy (fn, p, 1 + Length (fn) - p)
  234.     ELSE getFileExt := '';
  235. END;
  236.  
  237. FUNCTION getFileName (fn: STR128): NAMESTR;
  238. VAR
  239.   p: BYTE;
  240.   b: BOOLEAN;
  241. BEGIN
  242.   b := TRUE;
  243.   WHILE b DO
  244.   BEGIN
  245.     p := Pos ('\', fn);
  246.     IF (p > 1)
  247.       THEN fn := Copy (fn, p+1, Length (fn) - p)
  248.